Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue61/System/MainForm.pas

Pascal/Delphi Source File | 2000-08-07 | 7.3 KB | 225 lines

unit MainForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, ComCtrls, WinINet, ExtCtrls, FTPReader;

type
  TForm1 = class(TForm)
    FileList: TListView;
    CurrentDir: TLabel;
    Panel1: TPanel;
    Status: TLabel;
    UpButton: TButton;
    Download: TButton;
    SaveDialog: TSaveDialog;
    Animate1: TAnimate;
    procedure FileListDblClick(Sender: TObject);
    procedure UpButtonClick(Sender: TObject);
    procedure FileListCompare(Sender: TObject; Item1, Item2: TListItem; Data: Integer; var Compare: Integer);
    procedure FileListSelectItem(Sender: TObject; Item: TListItem; Selected: Boolean);
    procedure DownloadClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    hSession: HInternet;
    hFTP: HInternet;
    hFind: HInternet;
    ThisDir: String;
    FileReader: TFTPFileReader;
    procedure FileTransferComplete (Sender: TObject);
    procedure FileTransferProgress (Sender: TObject);
    procedure GetFileList (const Dir: String);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure MyCallBack (hHandle: HINTERNET; Self: TForm1; dwStatus: DWord; pStatus: Pointer; dwLen: DWord); stdcall;
var
    ErrNum, BuffSize: DWord;
    szBuff: array [0..1024] of Char;
begin
    BuffSize := sizeof (szBuff);
    if InternetGetLastResponseInfo (ErrNum, szBuff, BuffSize) then
        if (BuffSize > 0) and (szBuff [0] <> #0) then
            Self.Status.Caption := szBuff;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
    hSession := InternetOpen ('DelphiMagWinINetDemo', Internet_Open_Type_PreConfig, Nil, Nil, 0);
    if hSession = Nil then begin
        ShowMessage ('Can''t connect to the Internet');
        Application.Terminate;
    end;

    hFTP := InternetConnect (hSession, 'ftp.microsoft.com',
                             Internet_Default_FTP_Port, Nil, Nil,
                             Internet_Service_FTP, 0, Cardinal (Self));
    if hFTP = Nil then begin
        ShowMessage ('Can''t connect to ftp.microsoft.com');
        Application.Terminate;
    end;

    InternetSetStatusCallback (hFTP, @MyCallback);
    Status.Caption := 'Connected to ftp.microsoft.com';
    GetFileList (ThisDir);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
    if hFTP <> Nil then InternetCloseHandle (hFTP);
    if hSession <> Nil then InternetCloseHandle (hSession);
end;

procedure TForm1.GetFileList (const Dir: String);
var
    Item: TListItem;
    szDirSize: Cardinal;
    FileData: TWin32FindData;
    szDirectory: array [0..512] of Char;
begin
    Screen.Cursor := crHourGlass;
    try
        if Dir <> '' then FtpSetCurrentDirectory (hFTP, PChar (Dir));

        // Get current directory
        szDirSize := sizeof (szDirectory);
        if FtpGetCurrentDirectory (hFTP, szDirectory, szDirSize) then begin
            ThisDir := szDirectory;
            CurrentDir.Caption := 'Current Directory = ' + szDirectory;
        end;

        // The main enumeration loop
        FileList.Items.Clear;
        hFind := FtpFindFirstFile (hFTP, '*.*', FileData, 0, Cardinal (Self));
        if hFind <> Nil then try
            while True do begin
                if GetLastError = Error_No_More_Files then break;
                // We've got a file
                Item := FileList.Items.Add;
                Item.Caption := FileData.cFileName;
                // Is this a directory or a file?
                if FileData.dwFileAttributes = File_Attribute_Directory then begin
                    Item.Data := Pointer (1);
                    Item.SubItems.Add ('--dir--');
                end else begin
                    Item.Data := Nil;
                    Item.SubItems.Add (IntToStr (FileData.nFileSizeLow));
                end;

                if not InternetFindNextFile (hFind, @FileData) then break;
            end;
        finally
            InternetCloseHandle (hFind);
        end;
    finally
        Screen.Cursor := crDefault;
    end;
end;

procedure TForm1.FileListDblClick(Sender: TObject);
var
    Item: TListItem;
    NewDir: String;
begin
    Item := FileList.Selected;
    // Is this a directory double-click?
    if (Item <> Nil) and (Item.Data <> Nil) then begin
        NewDir := ThisDir;
        if NewDir = '' then NewDir := '/';
        if NewDir [Length (NewDir)] <> '/' then NewDir := NewDir + '/';
        ThisDir := NewDir + Item.Caption;
        GetFileList (ThisDir);
    end;

    // Is this a file double-click
    if (Item <> Nil) and (Item.Data = Nil) then DownloadClick (Sender);
end;

procedure TForm1.UpButtonClick(Sender: TObject);
var
    p: PChar;
    NewDir: array [0..512] of Char;
begin
    if (ThisDir <> '') and (ThisDir <> '/') then begin
        StrPCopy (NewDir, ThisDir);
        p := StrRScan (NewDir, '/');
        if p <> Nil then begin
            p^ := #0;
            ThisDir := NewDir;
            if ThisDir = '' then ThisDir := '/';
            GetFileList (ThisDir);
        end;
    end;
end;

procedure TForm1.FileListCompare(Sender: TObject; Item1, Item2: TListItem; Data: Integer; var Compare: Integer);
begin
    Compare := Ord (Ord (Item1.Data <> Nil) < Ord (Item2.Data <> Nil));
end;

procedure TForm1.FileListSelectItem (Sender: TObject; Item: TListItem; Selected: Boolean);
begin
    if Selected then Download.Enabled := Item.Data = Nil
    else Download.Enabled := False;
end;

procedure TForm1.FileTransferComplete (Sender: TObject);
begin
    Status.Caption := 'File Transfer Complete: Result = ' + FileReader.CompletionString;
    FileReader.Free;  FileReader := Nil;
    Screen.Cursor := crDefault;
    Enabled := True;
    MessageBeep (0);
end;

procedure TForm1.FileTransferProgress (Sender: TObject);
begin
    Status.Caption := 'Bytes transferred: ' + IntToStr (FileReader.TotalBytesRead);
    if FileReader.FileSize <> 0 then Status.Caption := Status.Caption + ' out of ' + IntToStr (FileReader.FileSize) + ' bytes';
end;

procedure TForm1.DownloadClick(Sender: TObject);
var
    Item: TListItem;
    DirName: String;
begin
    Item := FileList.Selected;
    // Double-check...
    if (Item <> Nil) and (Item.Data = Nil) then begin
        DirName := Copy (CurrentDir.Caption, 21, MaxInt);
        if MessageDlg ('Download ' + Item.Caption + ' from directory "' + DirName + '" ?', mtConfirmation, [mbYes, mbNo], 0) = mrYes then begin
            SaveDialog.FileName := Item.Caption;
            if SaveDialog.Execute then begin
                Screen.Cursor := crHourGlass;
                Enabled := False;
                FileReader := TFTPFileReader.Create;
                FileReader.SourceFileName := Item.Caption;
                FileReader.DestFileName := SaveDialog.FileName;
                FileReader.ServerName := 'ftp.microsoft.com';
                FileReader.NetConnection := hSession;
                FileReader.FTPSession := hFTP;
                FileReader.OnCompletion := FileTransferComplete;
                FileReader.OnProgress := FileTransferProgress;
                FileReader.Execute;
            end;
        end;
    end;
end;

end.